Cream of the Crop 26/Cream of the Crop 26.iso/program/p063b9s.zip/UNIT/OPROUTIL.PAS

Pascal/Delphi Source File | 1996-04-28 | 18KB | 660 lines

UNIT OproUtil;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ Misc. routines for OPro                       Last changed: 28.04.96  SA ║}
{║                                                                          ║}
{║                         (C) Copyright 1989-96 by                         ║}
{║       Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager        ║}
{║                                                                          ║}
{║ This source may not be given to anybody, without the written permission  ║}
{║ from The Portal Team.                                                    ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}

INTERFACE

USES Use32, Dos, OpCrt, OpWindow, OpMenu, OpField, OpEntry, OpRoot,
     PoPTypes;

CONST
  ptBitYesNoConversion = 2000;
  otBitYesNoEField     = 1101;
  veBitYesNoEField     = 0;

TYPE
  PBufTextFile = ^TBufTextFile;
  TBufTextFile = OBJECT(BufIdStream)
    ReadWrite : Boolean;

    CONSTRUCTOR Init(CONST FileName: PathStr; Mode, Size : Word);
    CONSTRUCTOR InitCreate(FileName: PathStr; Mode, Size: Word);
    PROCEDURE ReadLn(VAR s: String);
    PROCEDURE WriteLn(s: String);
    PROCEDURE WriteNoLn(s: String);
    PROCEDURE ReadLenStr(VAR s: String; Len: Byte);
    FUNCTION  EoF: Boolean;
  END;

  PPoPEntryScreen = ^TPoPEntryScreen;
  TPoPEntryScreen = OBJECT(ScrollingEntryScreen)
    CONSTRUCTOR Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
    DESTRUCTOR  Done; VIRTUAL;
    PROCEDURE   Process; VIRTUAL;
    PROCEDURE   AddBitYesNoField(Prompt: STRING;  pRow, pCol : Word;
                                 Picture: STRING; fRow, fCol : Word;
                                 HelpIndex: Word; BitNr: Byte; VAR EditBitYesNo: SmallWord);
  END;

  PBitYesNoField = ^TBitYesNoField;
  TBitYesNoField = OBJECT(EntryField)
    BitNr : Byte;

    constructor Init(ID : Word;               var Prompt : string;
                     pRow, pCol : Word;       var Picture : string;
                     fRow, fCol : Word;       HlpNdx : Word;
                     ABitNr: Byte; var EditBitYesNo : SmallWord; PadChar : Char;
                     Options, IFlags : LongInt; var Colors : ColorSet);
    procedure efIncrement; VIRTUAL;

    constructor Load(var S : IdStream);
    procedure  Store(var S : IdStream); VIRTUAL;
  END;

  PPoPMenu = ^TPoPMenu;
  TPoPMenu = OBJECT(Menu)
    CONSTRUCTOR Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
    DESTRUCTOR  Done; VIRTUAL;
    PROCEDURE   ProcessMenu(VAR Choice, LastCmd: Word);
  END;

{ Stream registration }
PROCEDURE TPoPEntryScreenStream(SPtr: IdStreamPtr);
PROCEDURE TPoPMenuStream(SPtr: IdStreamPtr);
PROCEDURE TBitYesNoFieldStream(SPtr: IdStreamPtr);

PROCEDURE CenterWindow(VAR x1, x2: Byte);

FUNCTION  MyWin(VAR w : WindowPtr; x1, y1, x2, y2, l : Byte; CONST s: String; Shadow: Boolean): Boolean;
PROCEDURE KillWindow(VAR w : WindowPtr);

PROCEDURE LoadMainMenu;
PROCEDURE MainMenuToggle;

FUNCTION GetDiskString(Drive: Char): S25;

IMPLEMENTATION

USES {$IFDEF OS2} Os2Base, VpRoot, {$ELSE} OpMacro, {$ENDIF} OpDos,
     OpInline, OpFrame, OpSelect, OpCmd, OpKey, OpAbsFld, OpFEdit, OpConst,
     Globals, Resource, PoPHelp;


{=== TBufTextFile ===}

  CONSTRUCTOR TBufTextFile.Init(CONST FileName: PathStr; Mode, Size: Word);
  BEGIN
    Size:=(Size DIV 512)*512;
    IF Size=0 THEN Size:=512;
    IF NOT INHERITED Init(FileName, Mode, Size) THEN Fail;
    IF GetStatus<>0 THEN
    BEGIN
      INHERITED Done;
      Fail;
    END;
    ReadWrite:=((Mode AND SOpen)=SOpen) OR ((Mode AND SCreate)=SCreate);
  END;

  CONSTRUCTOR TBufTextFile.InitCreate(FileName: PathStr; Mode, Size: Word);
  BEGIN
    IF NOT ExistFile(FileName) THEN Mode:=SCreate;
    IF NOT Init(FileName, Mode, Size) THEN Fail;
    SetPos(0, PosEnd);
  END;


  Procedure TBufTextFile.ReadLn(var S: String);
  var
    SPos : Byte;
    Ch   : Char;
{$IFNDEF OS2}
    Regs : Registers;
{$ENDIF}
  begin
    S[0]:=#0; SPos:=0; Ch:=#0;
{   if idStatus<>0 then Exit;}
    if ReadWrite and not FlushBuffer(1) then Exit;   { = FlushModeWrite }
    repeat
      if BufPtr>=BufEnd then
{$IFDEF OS2}
      asm
        push   ebx
        mov    eax,self
        mov    ebx,[eax].DosIdStream.Handle
        mov    ecx,[eax].DosIdStream.BufSize
        mov    edx,[eax].DosIdStream.Buffer
        mov    ah,3fh         { Read }
        Call   Os2DosFn
        jnc    @@1              { success }

        add     eax,epNonFatal  { error }
        push    eax
        mov     eax,Self
        push    eax
        Call    Error
        jmp     @@2
      @@1:

        mov     ebx,self
        xor     ecx,ecx
        mov     [ebx].DosIdStream.bufptr,ecx
        mov     [ebx].DosIdStream.bufend,eax

        or      eax,eax         { check if bytes read = 0 }
        jne     @@2
        mov     eax,epNonFatal  { nope - disk full }
        add     eax,ecDiskRead
        push    eax
        mov     eax,Self
        push    eax
        Call    Error
      @@2:
        pop     ebx
      end;
{$ELSE}
      begin
        with Regs do
        begin
          AH := $3F;
          BX := Handle;
          CX := BufSize;
          DX := OS(Buffer).O;
          DS := OS(Buffer).S;
          MsDos(Regs);
          BufPtr:=0;
          IF Odd(Flags) THEN BufEnd:=0 ELSE BufEnd:=AX;
        end;
      end;
{$ENDIF}
      WHILE (BufPtr<BufEnd) AND (Ch<>#10) DO
      BEGIN
        Ch:=Char(Buffer^[BufPtr]);
        IF (not (ch in [#13, #10])) AND (SPos<=255) THEN
        BEGIN
          Inc(SPos);
          s[SPos]:=ch;
        END;
        Inc(BufPtr);
      END;
    UNTIL (Ch=#10) or (BufEnd=0);
    S[0]:=Char(SPos);
  END;

  PROCEDURE TBufTextFile.WriteLn(s: String);
  BEGIN
    Write(s[1], Length(s));
    s:=#13#10;
    Write(s[1], Length(s));
  END;

  PROCEDURE TBufTextFile.WriteNoLn(s: String);
  BEGIN
    Write(s[1], Length(s));
  END;

  PROCEDURE TBufTextFile.ReadLenStr(VAR s: String; Len: Byte);
  BEGIN
    Read(s[1], Len);
    s[0]:=Char(Len);
  END;

{$IFDEF OS2}
  FUNCTION TBufTextFile.EoF: Boolean;
  VAR
    OldPos, NewPos : LongInt;
  BEGIN
    DosSetFilePtr(Handle, 0, FILE_CURRENT, OldPos);
    DosSetFilePtr(Handle, 0, FILE_END, NewPos);
    DosSetFilePtr(Handle, OldPos, FILE_BEGIN, OldPos);
    EoF:=(OldPos=NewPos) AND (BufPtr>=BufEnd);
  END;

{$ELSE}

  FUNCTION TBufTextFile.EoF: Boolean;
  VAR
    Regs : Registers;
    OldDX, OldAX,
    MaxDX, MaxAX : Word;
  BEGIN
    IF (BufPtr>0) AND (Succ(BufPtr)<BufEnd) THEN
      EoF:=False
    ELSE
    begin
(*
      ASM
        mov ax,$4201
        mov bx,Handle
        mov cx,0
        mov dx,0
        int $21
        mov OldDx,dx
        mov OldAx,ax

        mov ax,$4202
        mov bx,Handle
        mov cx,0
        mov dx,0
        int $21
        mov MaxDx,dx
        mov MaxAx,ax

        mov ax,$4200
        mov bx,Handle
        mov cx,OldDx
        mov dx,OldAX
        int $21
      END;
*)
      WITH Regs DO
      BEGIN
        ax:=$4201;
        bx:=Handle;
        cx:=0;
        dx:=0;
        MsDos(Regs);
        OldDX:=DX;
        OldAX:=AX;

        ax:=$4202;
        bx:=Handle;
        cx:=0;
        dx:=0;
        MsDos(Regs);
        MaxDX:=DX;
        MaxAX:=AX;

        ax:=$4200;
        bx:=Handle;
        cx:=OldDX;
        dx:=OldAX;
        MsDos(Regs);
      END;
      EoF:=(OldDX=MaxDX) AND (OldAX=MaxAX) AND (BufPtr>=BufEnd);
    END;
  END;
{$ENDIF}


{=== TPoPEntryScreen ===}

  CONSTRUCTOR TPoPEntryScreen.Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
  BEGIN
    CenterWindow(x1, x2);
    IF NOT INHERITED InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered+wClear) THEN Fail;
    WFrame.AddHeader(' '+s+' ',heTC);
    IF (x2<ScreenWidth-2) AND (y2<ScreenHeight-2) THEN WFrame.AddShadow(shBR, shSeeThru);
    IF cfg.Screen.ExplodingWin THEN EnableExplosions(10);
    esFieldOptionsOn(efClearFirstChar);
    SetWrapMode(ExitAtBot);
    EntryCommands.AddCommand(ccPrevRec,1,OpKey.PgUp,0);
    EntryCommands.AddCommand(ccNextRec,1,OpKey.PgDn,0);
    EntryCommands.SetHelpProc(HelpRoutine);
    Topic:=0;
  END;

  DESTRUCTOR TPoPEntryScreen.Done;
  BEGIN
    EraseHidden;
    INHERITED Done;
  END;

  PROCEDURE TPoPEntryScreen.Process;
  BEGIN
    ResetScreen;
    INHERITED Process;
  END;

  PROCEDURE TPoPEntryScreen.AddBitYesNoField(Prompt: STRING;  pRow, pCol : Word;
                                             Picture: STRING; fRow, fCol : Word;
                                             HelpIndex: Word; BitNr: Byte; VAR EditBitYesNo: SmallWord);
  VAR
    fWidth : Byte;
  BEGIN
    {check parameters before adding the field}
    fWidth := Length(Picture);
    if esParamsOK(Prompt, pRow, pCol, Picture, fRow, fCol, fWidth) then
      {allocate field and append it to the linked list}
      esAppendField(
        New(PBitYesNoField,
            Init(asCount, Prompt, pRow, pCol, Picture, fRow, fCol, HelpIndex,
                 BitNr, EditBitYesNo, esPadChar, asFieldOptions, esFieldFlags, asColors)));
  END;



  procedure BitYesNoConversion(EFP: EntryFieldPtr; PostEdit:  Boolean); far;
    {-Conversion routine for yes/no's}
  var
    Ch : Char;
    S : string[10];
  begin
    with PBitYesNoField(EFP)^ do
      if PostEdit then
      begin
        StripPicture(efEditSt^, S);
        Ch := S[1];
        IF Upcase(Ch) = YesChar THEN
          Word(efVarPtr^):=Word(efVarPtr^) OR (1 SHL BitNr)
        ELSE
          Word(efVarPtr^):=Word(efVarPtr^) AND NOT (1 SHL BitNr);
      end else
      begin
        if Word(efVarPtr^) AND (1 SHL BitNr) <> 0 then
          efEditSt^ := YesChar
        else
          efEditSt^ := NoChar;
        if Length(efEditSt^) < Length(efPicture^) then
          MergePicture(efEditSt^, efEditSt^);
      end;
  end;





  constructor TBitYesNoField.Init(ID : Word;               var Prompt : string;
                                  pRow, pCol : Word;       var Picture : string;
                                  fRow, fCol : Word;       HlpNdx : Word;
                                  ABitNr: Byte; var EditBitYesNo : SmallWord; PadChar : Char;
                                  Options, IFlags : LongInt; var Colors : ColorSet);
    {-Initialize an entry field of type yes-no}
  var
    fWidth : Byte;
  begin
    if Length(Picture) = 0 then
    begin
      Picture := YesNoOnly;
      fWidth := 1;
    end else
      fWidth := Length(Picture);

    if not INHERITED Init(
      ID, Prompt, pRow, pCol, Picture, fRow, fCol, fWidth, 1, HlpNdx,
      BlankRange, BlankRange, SizeOf(Boolean), 0, NullValidation, BitYesNoConversion,
      DrawString, CharEditor, EditBitYesNo, PadChar, Options or efClickExit,
      IFlags or ifBoolean, Colors) then
        Fail;
    BitNr:=ABitNr;
  end;

  procedure TBitYesNoField.efIncrement;
    {-Increment the value of the field}
  begin
    Word(efVarPtr^) := Word(efVarPtr^) XOR (1 SHL BitNr);
  end;

  constructor TBitYesNoField.Load(var S : IdStream);
  BEGIN
    INHERITED Load(S);
    S.Read(BitNr, SizeOf(BitNr));
  END;

  procedure TBitYesNoField.Store(var S : IdStream);
  BEGIN
    INHERITED Store(S);
    S.Write(BitNr, SizeOf(BitNr));
  END;

{***}


  procedure TBitYesNoFieldStream(SPtr : IdStreamPtr);
    {-Register all types}
  begin
    EntryFieldStream(SPtr);
    with SPtr^ do begin
      RegisterType(otBitYesNoEField, veBitYesNoEField, TypeOf(TBitYesNoField),
                   @TBitYesNoField.Store, @TBitYesNoField.Load);
      RegisterPointer(ptBitYesNoConversion, @BitYesNoConversion);
      RegisterPointer(ptDrawString, @DrawString);
      RegisterPointer(ptCharEditor, @CharEditor);
    end;
  end;


{=== TPoPMenu ===}

  CONSTRUCTOR TPoPMenu.Init(x1, y1, x2, y2, Col: Byte; CONST s: s78);
  BEGIN
    CenterWindow(x1, x2);
    IF NOT INHERITED InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered+wCoversOnDemand,Vertical) THEN Fail;
    WFrame.AddHeader(' '+s+' ',heTC);
    IF (x2<ScreenWidth-2) AND (y2<ScreenHeight-2) THEN AddShadow(shBR, shSeeThru);
    IF cfg.Screen.ExplodingWin THEN EnableExplosions(10);
    Topic:=0 ;
  END;

  DESTRUCTOR TPoPMenu.Done;
  BEGIN
    EraseHidden;
    INHERITED Done;
  END;

  PROCEDURE TPoPMenu.ProcessMenu(VAR Choice, LastCmd: Word);
  BEGIN
    Draw;
    Process;
    Choice:=MenuChoice;
    LastCmd:=GetLastCommand;
    Done;
   END;


{=== Stream Registration ===}

  PROCEDURE TPoPEntryScreenStream(SPtr: IdStreamPtr);
  BEGIN
    ScrollingEntryScreenStream(SPtr);
    SPtr^.RegisterType(otTPopEntryScreen, veTPoPEntryScreen,
                       TypeOf(TPoPEntryScreen),
                       @TPoPEntryScreen.Store, @TPoPEntryScreen.Load);
  END;

  PROCEDURE TPoPMenuStream(SPtr: IdStreamPtr);
  BEGIN
    MenuStream(SPtr);
    SPtr^.RegisterType(otTPopMenu, veTPoPMenu,
                       TypeOf(TPoPMenu),
                       @TPoPMenu.Store, @TPoPMenu.Load);
  END;


  PROCEDURE CenterWindow(VAR x1, x2: Byte);
  BEGIN
    IF ScreenWidth>80 THEN
    BEGIN
      Inc(x1, (ScreenWidth-80) DIV 2);
      Inc(x2, (ScreenWidth-80) DIV 2);
    END;
  END;

  FUNCTION MyWin(VAR w : WindowPtr; x1, y1, x2, y2, l : Byte; CONST s: String; Shadow: Boolean): Boolean;
  VAR
    Head : String;
    cs   : ColorSet;
    b    : LONGINT;
  BEGIN
    IF l=0 THEN cs:=DefaultColorSet ELSE cs:=Cfg.Color[l];
    b:=wClear+wSaveContents;
    CenterWindow(x1, x2);
    IF s='' THEN
    BEGIN
      Head:='';
    END ELSE
    BEGIN
      INC(x1);INC(y1);DEC(x2);DEC(y2);
      Head:=' '+s+' ';
      b:=b+wBordered;
    END;
    New(w, InitCustom(x1,y1,x2,y2,cs,b));
    IF w<>NIL THEN
    BEGIN
      w^.SetCursor(cuHidden);
      IF head<>'' THEN w^.WFrame.AddHeader(Head,heTC);
      IF Cfg.Screen.ExplodingWin THEN w^.EnableExplosions(10);
      IF Shadow THEN w^.wFrame.AddShadow(shBR,shSeeThru);
      w^.Draw;
      MyWin:=True;
    END ELSE
      MyWin:=False;
  END;

  PROCEDURE KillWindow(VAR w : WindowPtr);
  BEGIN
    w^.EraseHidden;
    Dispose(w, Done);
  END;


  PROCEDURE InitM(VAR M:Menu; x1,y1,x2,y2,col:BYTE; CONST s: STRING);
  BEGIN
    WITH m DO
    BEGIN
      CenterWindow(x1, x2);
      InitCustom(x1,y1,x2,y2,Cfg.Color[col],wBordered,Vertical);
      WFrame.AddHeader(' '+s+' ',heTC);
      IF cfg.Screen.ExplodingWin THEN EnableExplosions(6);
    END;
    Topic:=0 ;
  END;

  PROCEDURE _KillMenu(VAR m:Menu);
  BEGIN
    m.EraseHidden;
    m.Done;
  END;


  PROCEDURE MainCustomStringProc(var Name : String; Key : LongInt;
                                 Selected, Highlighted : Boolean;
                                 WPtr : RawWindowPtr); far;
  VAR
    s : S5;
  BEGIN
{$IFNDEF OS2}
    IF Key=93 THEN
    BEGIN
      IF MacrosAreOn THEN s:='Yes' ELSE s:=' No';
      Move(s[1], Name[Length(Name)-2], Length(s));
    END;
{$ENDIF}
  END;

  PROCEDURE LoadMainMenu;
  BEGIN
    IF MainMenu=NIL THEN
    BEGIN
      New(MainMenu);
      GetMenu(MnuMain, 2, MainMenu^);
      MainMenu^.SetCustomStringProc(MainCustomStringProc);
      MainMenu^.DefaultItem(100);
    END;
    MainMenuToggle;
  END;

  PROCEDURE MainMenuToggle;
  BEGIN
    WITH MainMenu^ DO
    BEGIN
      IF CmdLineFlags AND clNoModem<>0 THEN
      BEGIN
        ProtectItem(AltP);
        ProtectItem(AltD);
        ProtectItem(AltC);
        ProtectItem(210);
        ProtectItem(211);
        ProtectItem(212);
      END ELSE
      BEGIN
        UnProtectItem(AltP);
        UnProtectItem(AltD);
        UnProtectItem(AltC);
        UnProtectItem(210);
        UnProtectItem(211);
        UnProtectItem(212);
        IF Cfg.Modem.Answer='' THEN ProtectItem(211) ELSE UnProtectItem(211);
      END;

      IF OutList^.Size=0 THEN
      BEGIN
        ProtectItem(Plus);
        ProtectItem(Minus);
        ProtectItem(AltW);
        ProtectItem(AltI);
      END ELSE
      BEGIN
        UnProtectItem(Plus);
        UnProtectItem(Minus);
        UnProtectItem(AltW);
        UnProtectItem(AltI);
      END;

      IF Cfg.Screen.BlankTime=0 THEN ProtectItem(AltB) ELSE UnProtectItem(AltB);
      IF Cfg.Editor='' THEN ProtectItem(AltE) ELSE UnProtectItem(AltE);
      IF Cfg.BBS.BBSType=btNone THEN
      BEGIN
        ProtectItem(AltA);
        ProtectItem(AltQ);
        ProtectItem(AltU);
      END ELSE
      BEGIN
        UnProtectItem(AltA);
        UnProtectItem(AltQ);
        UnProtectItem(AltU);
      END;
{$IFNDEF OS2}
      IF MacroCount=0 THEN
      BEGIN
        ProtectItem(91);
        ProtectItem(92);
        ProtectItem(94);
        ProtectItem(97);
      END ELSE
      BEGIN
        UnProtectItem(91);
        UnProtectItem(92);
        UnProtectItem(94);
        UnProtectItem(97);
      END;
{$ENDIF}
{     ProtectItem(214);
      ProtectItem(215);}
    END;
  END;

  FUNCTION GetDiskString(Drive: Char): S25;
  VAR
    dc : DiskClass;
    sd : Char;
  BEGIN
    GetDiskString:='';
    dc:=GetDiskClass(Drive, sd);
    CASE dc OF
      Floppy360    : GetDiskString:='360KB floppy';
      Floppy720    : GetDiskString:='720KB floppy';
      Floppy12     : GetDiskString:='1.2MB floppy';
      Floppy144    : GetDiskString:='1.44MB floppy';
      OtherFloppy  : GetDiskString:='Unknown floppy';
      Bernoulli    : GetDiskString:='Bernoulli drive';
      HardDisk     : GetDiskString:='Hard disk';
      RamDisk      : GetDiskString:='Ram drive';
      SubstDrive   : GetDiskString:='Substitute of drive '+sd;
      UnknownDisk  : GetDiskString:='Unknown media';
      InvalidDrive : GetDiskString:='Invalid drive';
      NovellDrive  : GetDiskString:='Novell<tm> drive';
      CDRomDisk    : GetDiskString:='CD ROM drive';
    END;
  END;

END.